The following dataset is de-identified and already hosted on Github. The data come from one of my recent publications (Experiment 1; Miller, Gross, & Unsworth, 2019). In this paper, pupil dilation was used as an online indicator of the intensity of attention to determine whether variation in attention at encoding relates to individual differences in working memory capacity (WMC) and long-term memory (LTM) performance. Participants (N = 138) completed a battery of complex span working memory tasks, followed by a delayed free recall task while pupil dilation was simultaneously recorded.
data <- import(here("data", "DeIntentifiedJML2019Data_Exp1.sav"),
setclass = "tibble") %>%
characterize() %>%
janitor::clean_names()
# Select variables of interest for pupil data
pupil_data <- data %>%
select(-sp1_acc:-symspan,
-ineffective:-recency_recall,
-baseline_pupil_mean:-tepr_recency)
# Cam's efficient method to rename bin/word variables
# E.g., data currently reads ebin1w1pt4_mean
# I just want the variable to read bin1w1
pupil_data %<>%
rename_at(
vars(starts_with("ebin")),
funs(
paste(
str_extract(., "w\\d{1,2}"),
"_",
str_extract(., "bin\\d{1,2}"),
sep = "")))
Please note that for the following figures, I specified dimensions appropriate for a knitted html document. Also, just a heads up that it will probably take at least 5 minutes to generate the html because of the animated plots!
Here I plot changes in pupil diameter across the 3 second study/encoding phase for each word (i.e., bin).
# Tidy data:
plot1_data <- pupil_data %>%
gather(key = word_bin, value = TEPR, w1_bin1:w10_bin15) %>%
separate(word_bin, c("word", "bin"), sep = "_") %>%
mutate(word = parse_number(word),
bin = parse_number(bin)) %>%
arrange(subject)
#glimpse(plot1_data)
plot1 <- plot1_data %>%
group_by(bin) %>%
summarise(mean_TEPR = mean(TEPR, na.rm = TRUE),
se_TEPR = sundry::se(TEPR))
# This just makes the line begin at x = 0 and y = 0
plot1 <- rbind(plot1, "1st" = c(0, 0, 0))
# I want to model uncertainty with bootstrapping:
row_samps <- rerun(100,
sample(seq_len(nrow(plot1)),
nrow(plot1),
replace = TRUE))
# Extracting samples
d_samps <- map_df(row_samps, ~plot1[., ], .id = "sample")
# Plotting both data sources (my data and hypothetical/bootstrapped data)
plot1 <- ggplot(plot1, aes(x = bin, y = mean_TEPR)) +
stat_smooth(aes(group = sample),
data = d_samps,
geom = "line",
color = "#2DDADA",
fullrange = TRUE,
size = 0.1) +
theme_minimal() +
# Bold title and axes; left-align caption
theme(axis.title = element_text(face = "bold"),
plot.title = element_text(face = "bold"),
plot.caption = element_text(hjust = 0)) +
# Change labels
labs(caption = "Figure 1. Task evoked pupillary response across the 3 second study (encoding) phase for each word",
y = "Mean Pupil Diameter (mm)",
x = "Time (ms)") +
# Relabel x axis values to make more sense to reader
scale_x_continuous(breaks = c(0, 1, 2, 3, 4, 5, 6, 7, 8,
9, 10, 11, 12, 13, 14, 15),
labels = c("0", "200", "400", "600", "800", "1,000",
"1,200", "1,400", "1,600", "1,800", "2,000",
"2,200", "2,400", "2,600", "2,800", "3,000"),
limits = c(0, NA)) +
# Add text specifying when stimuli appear onscreen
geom_text(y = 0.04,
x = 1.4,
color = "gray80",
label = " To-be-remembered
word appears onscreen", size = 3, fontface = 2) +
# Add dotted vertical line at x = 0
geom_vline(aes(xintercept = 0),
color = "gray80",
lty = "dashed")
# Creating my own theme
bbg_darktheme <- theme(panel.grid.major = element_line(colour = "gray20"),
panel.grid.minor = element_line(colour = "gray20"),
axis.text = element_text(colour = "gray80"),
axis.text.x = element_text(colour = "gray80"),
axis.text.y = element_text(colour = "gray80"),
axis.title = element_text(colour = "gray80", face = "bold"),
legend.text = element_text(colour = "gray80"),
legend.title = element_text(colour = "gray80"),
plot.subtitle = element_text(colour = "gray80"),
strip.text = element_text(colour = "gray80", face = "bold"),
panel.background = element_rect(fill = "gray10"),
plot.background = element_rect(fill = "gray10"),
legend.background = element_rect(fill = NA, color = NA),
plot.margin = margin(10, 10, b = 20, 10),
plot.caption = element_text(colour = "gray80", vjust = 1),
plot.title = element_text(colour = "gray80", face = "bold"))
# Apply my theme to plot
plot1 + bbg_darktheme
Here I plot pupil diameter as a function of serial position for high WMC (n = 33), medium WMC (n = 69) and low WMC (n = 31) individuals.
#Reordering factor levels for legend
plot1_data$span_group <- factor(plot1_data$span_group,
levels = c("Low", "Medium", "High"))
plot2data <- plot1_data %>%
group_by(word, span_group) %>%
summarise(mean_TEPR = mean(TEPR, na.rm = TRUE),
se_TEPR = sundry::se(TEPR))
# Rename variable for legend
plot2data %<>%
rename("WMC" = `span_group`)
plot2 <- ggplot(plot2data, aes(x = word, y = mean_TEPR)) +
geom_ribbon(aes(ymin = mean_TEPR - 1.96*se_TEPR,
ymax = mean_TEPR + 1.96*se_TEPR,
fill = WMC),
alpha = 0.4) +
scale_fill_carto_d(palette = "Burg") +
theme_minimal() +
# Left-align caption
theme(plot.caption = element_text(hjust = 0)) +
# Change labels
labs(caption = "Figure 2. Pupillary response across serial positions for low working memory capacity (WMC) individuals
(n = 31), medium WMC individuals (n = 69), and high WMC individuals (n = 33).",
y = "Mean Pupil Diameter (mm)",
x = "Serial position",
colour = "WMC") +
# Relabel x axis values to make more sense to reader
scale_x_continuous(breaks = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10),
labels = c("1", "2", "3", "4", "5",
"6", "7", "8", "9", "10"))
plot2 + bbg_darktheme
Now I will attempt to plot pupil diameter as a function of serial position (broken down into Primacy (words 1–3), Mid (words 4–7), and Recency (words 8–10)) and bin (time across the 3 second study phase for each word) based on one’s WMC.
# Converting word # to factors
plot1_data$word <- as.factor(plot1_data$word)
# Breaking down words into primacy, mid, and recency items
plot3_data <- plot1_data %>%
mutate(word = recode(word, '1' = "Primacy Items",
'2' = "Primacy Items",
'3' = "Primacy Items",
'4' = "Mid Items",
'5' = "Mid Items",
'6' = "Mid Items",
'7' = "Mid Items",
'8' = "Recency Items",
'9' = "Recency Items",
'10' = "Recency Items"))
plot3_data %<>%
group_by(word, bin, span_group) %>%
summarise(mean_TEPR = mean(TEPR, na.rm = TRUE),
se_TEPR = sundry::se(TEPR))
plot3 <- ggplot(plot3_data, aes(x = bin, y = mean_TEPR, colour = span_group)) +
geom_point(size = 0.8) +
# Generate outcome draws from a fitted model
stat_smooth_draws(times = 10,
aes(group = interaction(stat(.draw), colour)),
size = 0.8) +
scale_color_carto_d(palette = "Burg") +
# Create seperate plots for Primacy, Mid, and Recency Items
facet_wrap(~word) +
# Specifying sampled draws in addition to the animated lines
transition_states(stat(.draw), 1, 2) +
enter_fade() + exit_fade() +
shadow_mark(future = TRUE, size = 0.25, color = "gray50", alpha = 1/4) +
theme_minimal() +
# Rotate x axis values so they are angled; center subtitle
# Left-align caption
theme(axis.text.x = element_text(angle = 45, hjust = 1),
plot.caption = element_text(hjust = 0),
plot.subtitle = element_text(face = "bold", hjust = 0.5)) +
# Change labels
labs(caption = "Figure 3. Pupil diameter as a function of serial position and time across encoding period for low WMC (n = 31), medium WMC
(n = 69), and high WMC (n = 33) individuals. Serial position was broken down into Primacy (words 1–3), Mid (words 4–7),
and Recency (words 8–10) for graphical purposes only.",
y = "Mean Pupil Diameter (mm)",
x = "Time (ms)",
colour = "WMC") +
# Adjust/Relabel x axis values to make more sense to reader
scale_x_continuous(breaks = c(0, 2, 4, 6, 8, 10, 12, 14),
labels = c("0", "400", "800", "1,200",
"1,600", "2,000", "2,400","2,800"),
limits = c(0, NA)) +
# Adjust/Relabel y axis values to make more sense to reader
scale_y_continuous(breaks = c(-0.10, -0.05, 0.00, 0.05, 0.10, 0.15),
label = c("-0.10", "-0.05", "0.00",
"0.05", "0.10", "0.15"),
limits = c(-0.10, 0.15))
plot3 + bbg_darktheme
Above I faceted by serial position (primacy, mid, recency). In Miller et al. (2019), I actually faceted by WMC (low, mid, high). I honestly don’t know which method I prefer. For comparision sake, let’s try to reproduce the plot faceting by WMC:
# Specify factor levels
plot3_data$word <- factor(plot3_data$word,
levels = c("Primacy Items",
"Mid Items",
"Recency Items"))
# Rename variables to enhance clarity
plot3_data %<>%
mutate(span_group = recode(span_group,
'Low' = "Low WMC",
'Medium' = "Medium WMC",
'High' = "High WMC"))
plot3.2 <- ggplot(plot3_data, aes(x = bin, y = mean_TEPR, colour = word)) +
geom_point(size = 0.8) +
# Generate outcome draws from a fitted model
stat_smooth_draws(times = 10,
aes(group = interaction(stat(.draw), colour)),
size = 0.8) +
scale_color_carto_d(palette = "Burg") +
# Create seperate plots for people with low, mid, and high WMC
facet_wrap(~span_group) +
# Specifying sampled draws in addition to the animated lines
transition_states(stat(.draw), 1, 2) +
enter_fade() + exit_fade() +
shadow_mark(future = TRUE, size = 0.25, color = "gray50", alpha = 1/4) +
theme_minimal() +
# Rotate x axis values so they are angled; center subtitle
# Left-align caption
theme(axis.text.x = element_text(angle = 45, hjust = 1),
plot.caption = element_text(hjust = 0),
plot.subtitle = element_text(face = "bold", hjust = 0.5)) +
# Change labels
labs(caption = "Figure 3. Pupil diameter as a function of serial position and time across encoding period for low WMC (n = 31), medium WMC
(n = 69), and high WMC (n = 33) individuals. Serial position was broken down into Primacy (words 1–3), Mid (words 4–7),
and Recency (words 8–10) for graphical purposes only.",
y = "Mean Pupil Diameter (mm)",
x = "Time (ms)",
colour = "Serial Position") +
# Adjust/Relabel x axis values to make more sense to reader
scale_x_continuous(breaks = c(0, 2, 4, 6, 8, 10, 12, 14),
labels = c("0", "400", "800", "1,200",
"1,600", "2,000", "2,400","2,800"),
limits = c(0, NA)) +
# Adjust/Relabel y axis values to make more sense to reader
scale_y_continuous(breaks = c(-0.10, -0.05, 0.00, 0.05, 0.10, 0.15),
label = c("-0.10", "-0.05", "0.00",
"0.05", "0.10", "0.15"),
limits = c(-0.10, 0.15))
plot3.2 + bbg_darktheme
Here I attempt to plot relation between recall accuracy and strategy type.
# Select variables of interest
strategy_data <- data %>%
select(-sp1_acc:-sp10_acc,
-ospan:-span_group,
-primacy_recall:-ebin15w10pt4_mean) %>%
gather(key = strat_type, value = response, passive_read_strat:other_strat)
# Filter out NAs, and convert strategy type and score to factors
strategy_data %<>%
filter(response != "NA") %>%
mutate(strat_type = as.factor(strat_type),
response = as.factor(response))
#levels(as.factor(strategy_data$strat_type))
# Recode variables for graph
strategy_data %<>%
mutate(strat_type = recode(strat_type,
"grouping_strat" = "Grouping",
"imagery_strat" = "Imagery",
"other_strat" = "Other",
"passive_read_strat" = "Passive Reading",
"rehearsal_strat" = "Rote Rehearsal",
"sentence_gen_strat" = "Sentence Generation")) %>%
group_by(strat_type, response) %>%
summarise(mean_acc = mean(accuracy_mean, na.rm = TRUE),
se_acc = sundry::se(accuracy_mean))
# Specify factor levels
# Effective strategies = imagery, sentence generation, and grouping
# Ineffective strategies = rehearsal and passive reading
strategy_data$strat_type <- factor(strategy_data$strat_type,
levels = c("Imagery",
"Sentence Generation",
"Grouping",
"Rote Rehearsal",
"Passive Reading",
"Other"))
plot4 <- strategy_data %>%
#filter out other and grouping strategy
filter(strat_type != "Other" & strat_type != "Grouping") %>%
ggplot(aes(response, mean_acc, fill = response)) +
geom_col(width = 0.60,
alpha = 0.6) +
geom_errorbar(aes(ymin = mean_acc + qnorm(0.025)*se_acc,
ymax = mean_acc + qnorm(0.975)*se_acc),
color = "gray40",
width = 0.4,
size = 0.8) +
# Print accuracy associated with each condition
geom_text(aes(response, mean_acc, label = paste0(round(mean_acc*100), "%")),
nudge_y = 0.15, # Specifies how high above bar text appears
size = 3,
color = "gray80") +
# Provide seperate graphs for each strategy
facet_wrap(~strat_type) +
scale_fill_carto_d(palette = "Burg") +
theme_minimal() +
# Delete legend and left-align caption
theme(legend.position="none",
plot.caption = element_text(hjust = 0)) +
#Modify labels
labs(title = "Recall Accuracy as a Function of Strategy Type and Use of Strategy",
y = "Mean Recall Accuracy",
x = "",
caption = "'No' represents individuals who did not report using given strategy, whereas 'Yes' represents whose who used said strategy.
Note that performance is actually better when people report not using a normatively ineffective strategy (e.g., rote rehearsal
or passive reading) than when they report using these strategies.") +
# Rename labels on x-axis
scale_x_discrete(breaks = c(0, 1),
labels = c("No", "Yes")) +
# Modify names/range of y-axis
scale_y_continuous(breaks = c(0, 0.2, 0.4, 0.6, 0.8),
labels = c("0%", "20%", "40%", "60%", "80%"),
limits = c(0, 0.8))
# Applying my theme to plot
plot4 + bbg_darktheme